home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / comobj.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  46.4 KB  |  1,594 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Runtime Library                          }
  5. {                                                       }
  6. {       Copyright (C) 1997 Borland International        }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ComObj;
  11.  
  12. interface
  13.  
  14. uses Windows, ActiveX, SysUtils;
  15.  
  16. type
  17.  
  18. { Forward declarations }
  19.  
  20.   TComObjectFactory = class;
  21.  
  22. { COM server abstract base class }
  23.  
  24.   TComServerObject = class(TObject)
  25.   protected
  26.     function CountObject(Created: Boolean): Integer; virtual; abstract;
  27.     function CountFactory(Created: Boolean): Integer; virtual; abstract;
  28.     function GetHelpFileName: string; virtual; abstract;
  29.     function GetServerFileName: string; virtual; abstract;
  30.     function GetServerKey: string; virtual; abstract;
  31.     function GetServerName: string; virtual; abstract;
  32.     function GetTypeLib: ITypeLib; virtual; abstract;
  33.   public
  34.     property HelpFileName: string read GetHelpFileName;
  35.     property ServerFileName: string read GetServerFileName;
  36.     property ServerKey: string read GetServerKey;
  37.     property ServerName: string read GetServerName;
  38.     property TypeLib: ITypeLib read GetTypeLib;
  39.   end;
  40.  
  41. { COM class manager }
  42.  
  43.   TFactoryProc = procedure(Factory: TComObjectFactory) of object;
  44.  
  45.   TComClassManager = class(TObject)
  46.   private
  47.     FFactoryList: TComObjectFactory;
  48.     procedure AddObjectFactory(Factory: TComObjectFactory);
  49.     procedure RemoveObjectFactory(Factory: TComObjectFactory);
  50.   public
  51.     procedure ForEachFactory(ComServer: TComServerObject;
  52.       FactoryProc: TFactoryProc);
  53.     function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  54.     function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  55.   end;
  56.  
  57. { COM object }
  58.  
  59.   TComObject = class(TObject, IUnknown, ISupportErrorInfo)
  60.   private
  61.     FRefCount: Integer;
  62.     FFactory: TComObjectFactory;
  63.     FController: Pointer;
  64.     function GetController: IUnknown;
  65.   protected
  66.     { IUnknown }
  67.     function IUnknown.QueryInterface = ObjQueryInterface;
  68.     function IUnknown._AddRef = ObjAddRef;
  69.     function IUnknown._Release = ObjRelease;
  70.     { IUnknown methods for other interfaces }
  71.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  72.     function _AddRef: Integer; stdcall;
  73.     function _Release: Integer; stdcall;
  74.     { ISupportErrorInfo }
  75.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  76.   public
  77.     constructor Create;
  78.     constructor CreateAggregated(const Controller: IUnknown);
  79.     constructor CreateFromFactory(Factory: TComObjectFactory;
  80.       const Controller: IUnknown);
  81.     destructor Destroy; override;
  82.     procedure Initialize; virtual;
  83.     function ObjAddRef: Integer; virtual; stdcall;
  84.     function ObjQueryInterface(const IID: TGUID; out Obj): Integer; virtual; stdcall;
  85.     function ObjRelease: Integer; virtual; stdcall;
  86.     function SafeCallException(ExceptObject: TObject;
  87.       ExceptAddr: Pointer): HResult; override;
  88.     property Controller: IUnknown read GetController;
  89.     property Factory: TComObjectFactory read FFactory;
  90.     property RefCount: Integer read FRefCount;
  91.   end;
  92.  
  93. { COM class }
  94.  
  95.   TComClass = class of TComObject;
  96.  
  97. { Instancing mode for COM classes }
  98.  
  99.   TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
  100.  
  101. { COM object factory }
  102.  
  103.   TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
  104.   private
  105.     FNext: TComObjectFactory;
  106.     FComServer: TComServerObject;
  107.     FComClass: TClass;
  108.     FClassID: TGUID;
  109.     FClassName: string;
  110.     FDescription: string;
  111.     FErrorIID: TGUID;
  112.     FInstancing: TClassInstancing;
  113.     FRegister: Longint;
  114.     FSupportsLicensing: Boolean;
  115.     FLicString: WideString;
  116.     function GetProgID: string;
  117.   protected
  118.     function GetLicenseString: WideString; virtual;
  119.     function HasMachineLicense: Boolean; virtual;
  120.     function ValidateUserLicense(const LicStr: WideString): Boolean; virtual;
  121.     { IUnknown }
  122.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  123.     function _AddRef: Integer; stdcall;
  124.     function _Release: Integer; stdcall;
  125.     { IClassFactory }
  126.     function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
  127.       out Obj): HResult; stdcall;
  128.     function LockServer(fLock: BOOL): HResult; stdcall;
  129.     { IClassFactory2 }
  130.     function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
  131.     function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall;
  132.     function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown;
  133.       const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall;
  134.   public
  135.     constructor Create(ComServer: TComServerObject; ComClass: TComClass;
  136.       const ClassID: TGUID; const ClassName, Description: string;
  137.       Instancing: TClassInstancing);
  138.     destructor Destroy; override;
  139.     function CreateComObject(const Controller: IUnknown): TComObject; virtual;
  140.     procedure RegisterClassObject;
  141.     procedure UpdateRegistry(Register: Boolean); virtual;
  142.     property ClassID: TGUID read FClassID;
  143.     property ClassName: string read FClassName;
  144.     property ComClass: TClass read FComClass;
  145.     property ComServer: TComServerObject read FComServer;
  146.     property Description: string read FDescription;
  147.     property ErrorIID: TGUID read FErrorIID write FErrorIID;
  148.     property ProgID: string read GetProgID;
  149.     property Instancing: TClassInstancing read FInstancing;
  150.     property SupportsLicensing: Boolean read FSupportsLicensing write FSupportsLicensing;
  151.     property LicString: WideString read FLicString write FLicString;
  152.   end;
  153.  
  154. { COM object with type information }
  155.  
  156.   TTypedComObject = class(TComObject, IProvideClassInfo)
  157.   protected
  158.     { IProvideClassInfo }
  159.     function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
  160.   end;
  161.  
  162.   TTypedComClass = class of TTypedComObject;
  163.  
  164.   TTypedComObjectFactory = class(TComObjectFactory)
  165.   private
  166.     FClassInfo: ITypeInfo;
  167.   public
  168.     constructor Create(ComServer: TComServerObject;
  169.       TypedComClass: TTypedComClass; const ClassID: TGUID;
  170.       Instancing: TClassInstancing);
  171.     function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
  172.     procedure UpdateRegistry(Register: Boolean); override;
  173.     property ClassInfo: ITypeInfo read FClassInfo;
  174.   end;
  175.  
  176. { OLE Automation object }
  177.  
  178.   TAutoObject = class(TTypedComObject, IDispatch)
  179.   protected
  180.     { IDispatch }
  181.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  182.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
  183.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
  184.     function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
  185.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  186.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
  187.   end;
  188.  
  189. { OLE Automation class }
  190.  
  191.   TAutoClass = class of TAutoObject;
  192.  
  193. { OLE Automation object factory }
  194.  
  195.   TAutoObjectFactory = class(TTypedComObjectFactory)
  196.   private
  197.     FDispTypeInfo: ITypeInfo;
  198.     FDispIntfEntry: PInterfaceEntry;
  199.   public
  200.     constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
  201.       const ClassID: TGUID; Instancing: TClassInstancing);
  202.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
  203.     property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
  204.     property DispTypeInfo: ITypeInfo read FDispTypeInfo;
  205.   end;
  206.  
  207.   TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
  208.   private
  209.     FDispTypeInfo: ITypeInfo;
  210.     FDispIntfEntry: PInterfaceEntry;
  211.     FDispIID: TGUID;
  212.   protected
  213.     { IDispatch }
  214.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  215.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  216.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  217.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  218.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  219.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  220.     { ISupportErrorInfo }
  221.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  222.   public
  223.     constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  224.     function SafeCallException(ExceptObject: TObject;
  225.       ExceptAddr: Pointer): HResult; override;
  226.     property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
  227.     property DispTypeInfo: ITypeInfo read FDispTypeInfo;
  228.     property DispIID: TGUID read FDispIID;
  229.   end;
  230.  
  231. { OLE exception classes }
  232.  
  233.   EOleError = class(Exception);
  234.  
  235.   EOleSysError = class(EOleError)
  236.   private
  237.     FErrorCode: Integer;
  238.   public
  239.     constructor Create(const Message: string; ErrorCode: Integer;
  240.       HelpContext: Integer);
  241.     property ErrorCode: Integer read FErrorCode write FErrorCode;
  242.   end;
  243.  
  244.   EOleException = class(EOleSysError)
  245.   private
  246.     FSource: string;
  247.     FHelpFile: string;
  248.   public
  249.     constructor Create(const Message: string; ErrorCode: Integer;
  250.       const Source, HelpFile: string; HelpContext: Integer);
  251.     property HelpFile: string read FHelpFile write FHelpFile;
  252.     property Source: string read FSource write FSource;
  253.   end;
  254.  
  255. { Dispatch call descriptor }
  256.  
  257.   PCallDesc = ^TCallDesc;
  258.   TCallDesc = packed record
  259.     CallType: Byte;
  260.     ArgCount: Byte;
  261.     NamedArgCount: Byte;
  262.     ArgTypes: array[0..255] of Byte;
  263.   end;
  264.  
  265.   PDispDesc = ^TDispDesc;
  266.   TDispDesc = packed record
  267.     DispID: Integer;
  268.     ResType: Byte;
  269.     CallDesc: TCallDesc;
  270.   end;
  271.  
  272. var
  273.   ComClassManager: TComClassManager;
  274.  
  275. function CreateComObject(const ClassID: TGUID): IUnknown;
  276. function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown;
  277. function CreateOleObject(const ClassName: string): IDispatch;
  278. function GetActiveOleObject(const ClassName: string): IDispatch;
  279.  
  280. procedure OleError(ErrorCode: HResult);
  281. procedure OleCheck(Result: HResult);
  282.  
  283. function StringToGUID(const S: string): TGUID;
  284. function GUIDToString(const ClassID: TGUID): string;
  285.  
  286. function ProgIDToClassID(const ProgID: string): TGUID;
  287. function ClassIDToProgID(const ClassID: TGUID): string;
  288.  
  289. procedure CreateRegKey(const Key, ValueName, Value: string);
  290. procedure DeleteRegKey(const Key: string);
  291.  
  292. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  293.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  294. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  295.  
  296. function HandleSafeCallException(ExceptObject: TObject;
  297.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  298.   HelpFileName: WideString): HResult;
  299.   
  300. function StringToLPOLESTR(const Source: string): POleStr;
  301.  
  302. procedure ReadPropFromBag(PropBag: IPropertyBag; ErrorLog: IErrorLog;
  303.   const Name: string; var Value: Variant);
  304. procedure PutPropInBag(PropBag: IPropertyBag; const Name: string;
  305.   const Value: Variant);
  306. procedure RegisterComServer(const DLLName: string);
  307.  
  308. implementation
  309.  
  310. {$I COMOBJ.INC}
  311.  
  312. const
  313.  
  314. { Maximum number of dispatch arguments }
  315.  
  316.   MaxDispArgs = 32; {!!!}
  317.  
  318. { Special variant type codes }
  319.  
  320.   varStrArg = $0048;
  321.  
  322. { Parameter type masks }
  323.  
  324.   atVarMask  = $3F;
  325.   atTypeMask = $7F;
  326.   atByRef    = $80;
  327.  
  328. var
  329.   OleUninitializing: Boolean;
  330.  
  331. { Raise EOleSysError exception from an error code }
  332.  
  333. procedure OleError(ErrorCode: HResult);
  334. begin
  335.   raise EOleSysError.Create('', ErrorCode, 0);
  336. end;
  337.  
  338. { Raise EOleSysError exception if result code indicates an error }
  339.  
  340. procedure OleCheck(Result: HResult);
  341. begin
  342.   if Result < 0 then OleError(Result);
  343. end;
  344.  
  345. { Convert a string to a GUID }
  346.  
  347. function StringToGUID(const S: string): TGUID;
  348. begin
  349.   OleCheck(CLSIDFromString(PWideChar(WideString(S)), Result));
  350. end;
  351.  
  352. { Convert a GUID to a string }
  353.  
  354. function GUIDToString(const ClassID: TGUID): string;
  355. var
  356.   P: PWideChar;
  357. begin
  358.   OleCheck(StringFromCLSID(ClassID, P));
  359.   Result := P;
  360.   CoTaskMemFree(P);
  361. end;
  362.  
  363. { Convert a programmatic ID to a class ID }
  364.  
  365. function ProgIDToClassID(const ProgID: string): TGUID;
  366. begin
  367.   OleCheck(CLSIDFromProgID(PWideChar(WideString(ProgID)), Result));
  368. end;
  369.  
  370. { Convert a class ID to a programmatic ID }
  371.  
  372. function ClassIDToProgID(const ClassID: TGUID): string;
  373. var
  374.   P: PWideChar;
  375. begin
  376.   OleCheck(ProgIDFromCLSID(ClassID, P));
  377.   Result := P;
  378.   CoTaskMemFree(P);
  379. end;
  380.  
  381. { Create registry key }
  382.  
  383. procedure CreateRegKey(const Key, ValueName, Value: string);
  384. var
  385.   Handle: HKey;
  386.   Status, Disposition: Integer;
  387. begin
  388.   Status := RegCreateKeyEx(HKEY_CLASSES_ROOT, PChar(Key), 0, '',
  389.     REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle,
  390.     @Disposition);
  391.   if Status = 0 then
  392.   begin
  393.     Status := RegSetValueEx(Handle, PChar(ValueName), 0, REG_SZ,
  394.       PChar(Value), Length(Value) + 1);
  395.     RegCloseKey(Handle);
  396.   end;
  397.   if Status <> 0 then raise EOleError.Create(SCreateRegKeyError);
  398. end;
  399.  
  400. { Delete registry key }
  401.  
  402. procedure DeleteRegKey(const Key: string);
  403. begin
  404.   RegDeleteKey(HKEY_CLASSES_ROOT, PChar(Key));
  405. end;
  406.  
  407. function CreateComObject(const ClassID: TGUID): IUnknown;
  408. begin
  409.   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
  410.     CLSCTX_LOCAL_SERVER, IUnknown, Result));
  411. end;
  412.  
  413. type
  414.   TCoCreateInstanceExProc = function (const clsid: TCLSID;
  415.     unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo: PCoServerInfo;
  416.     dwCount: Longint; rgmqResults: PMultiQIArray): HResult stdcall;
  417.  
  418. var
  419.   CoCreateInstanceEx: TCoCreateInstanceExProc = nil;
  420.   OleLib: HINST = 0;
  421.  
  422. function CreateRemoteComObject(const MachineName: WideString;
  423.   const ClassID: TGUID): IUnknown;
  424. var
  425.   ServerInfo: TCoServerInfo;
  426.   MQI: TMultiQI;
  427. begin
  428.   if @CoCreateInstanceEx = nil then
  429.   begin
  430.     OleLib := LoadLibrary('ole32.dll');
  431.     @CoCreateInstanceEx := GetProcAddress(OleLib, 'CoCreateInstanceEx');
  432.     if @CoCreateInstanceEx = nil then
  433.       raise Exception.Create(SDCOMNotInstalled);
  434.   end;
  435.   FillChar(ServerInfo, sizeof(ServerInfo), 0);
  436.   ServerInfo.pwszName := PWideChar(MachineName);
  437.   MQI.IID := @ClassID;
  438.   MQI.itf := nil;
  439.   MQI.hr := 0;
  440.   OleCheck(CoCreateInstanceEx(ClassID, nil, CLSCTX_REMOTE_SERVER,
  441.     @ServerInfo, 1, @MQI));
  442.   OleCheck(MQI.HR);
  443.   Result := MQI.itf;
  444. end;
  445.  
  446. function CreateOleObject(const ClassName: string): IDispatch;
  447. var
  448.   ClassID: TCLSID;
  449. begin
  450.   ClassID := ProgIDToClassID(ClassName);
  451.   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
  452.     CLSCTX_LOCAL_SERVER, IDispatch, Result));
  453. end;
  454.  
  455. function GetActiveOleObject(const ClassName: string): IDispatch;
  456. var
  457.   ClassID: TCLSID;
  458.   Unknown: IUnknown;
  459. begin
  460.   ClassID := ProgIDToClassID(ClassName);
  461.   OleCheck(GetActiveObject(ClassID, nil, Unknown));
  462.   OleCheck(Unknown.QueryInterface(IDispatch, Result));
  463. end;
  464.  
  465. procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer);
  466. var
  467.   ErrorInfo: IErrorInfo;
  468.   Source, Description, HelpFile: WideString;
  469.   HelpContext: Longint;
  470. begin
  471.   HelpContext := 0;
  472.   if GetErrorInfo(0, ErrorInfo) = S_OK then
  473.   begin
  474.     ErrorInfo.GetSource(Source);
  475.     ErrorInfo.GetDescription(Description);
  476.     ErrorInfo.GetHelpFile(HelpFile);
  477.     ErrorInfo.GetHelpContext(HelpContext);
  478.   end;
  479.   raise EOleException.Create(Description, ErrorCode, Source,
  480.     HelpFile, HelpContext) at ErrorAddr;
  481. end;
  482.  
  483. function TrimPunctuation(const S: string): string;
  484. var
  485.   Len: Integer;
  486. begin
  487.   Len := Length(S);
  488.   while (Len > 0) and (S[Len] in [#0..#32, '.']) do Dec(Len);
  489.   Result := Copy(S, 1, Len);
  490. end;
  491.  
  492. { Call Invoke method on the given IDispatch interface using the given
  493.   call descriptor, dispatch IDs, parameters, and result }
  494.  
  495. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  496.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  497. type
  498.   PVarArg = ^TVarArg;
  499.   TVarArg = array[0..3] of Integer;
  500.   TStringDesc = record
  501.     BStr: PWideChar;
  502.     PStr: PString;
  503.   end;
  504. var
  505.   I, J, K, ArgType, ArgCount, StrCount, DispID, InvKind, Status: Integer;
  506.   VarFlag: Byte;
  507.   ParamPtr: ^Integer;
  508.   ArgPtr, VarPtr: PVarArg;
  509.   DispParams: TDispParams;
  510.   ExcepInfo: TExcepInfo;
  511.   Strings: array[0..MaxDispArgs - 1] of TStringDesc;
  512.   Args: array[0..MaxDispArgs - 1] of TVarArg;
  513. begin
  514.   StrCount := 0;
  515.   try
  516.     ArgCount := CallDesc^.ArgCount;
  517.     if ArgCount <> 0 then
  518.     begin
  519.       ParamPtr := Params;
  520.       ArgPtr := @Args[ArgCount];
  521.       I := 0;
  522.       repeat
  523.         Dec(Integer(ArgPtr), SizeOf(TVarData));
  524.         ArgType := CallDesc^.ArgTypes[I] and atTypeMask;
  525.         VarFlag := CallDesc^.ArgTypes[I] and atByRef;
  526.         if ArgType = varError then
  527.         begin
  528.           ArgPtr^[0] := varError;
  529.           ArgPtr^[2] := DISP_E_PARAMNOTFOUND;
  530.         end else
  531.         begin
  532.           if ArgType = varStrArg then
  533.           begin
  534.             with Strings[StrCount] do
  535.               if VarFlag <> 0 then
  536.               begin
  537.                 BStr := StringToOleStr(PString(ParamPtr^)^);
  538.                 PStr := PString(ParamPtr^);
  539.                 ArgPtr^[0] := varOleStr or varByRef;
  540.                 ArgPtr^[2] := Integer(@BStr);
  541.               end else
  542.               begin
  543.                 BStr := StringToOleStr(PString(ParamPtr)^);
  544.                 PStr := nil;
  545.                 ArgPtr^[0] := varOleStr;
  546.                 ArgPtr^[2] := Integer(BStr);
  547.               end;
  548.             Inc(StrCount);
  549.           end else
  550.           if VarFlag <> 0 then
  551.           begin
  552.             if (ArgType = varVariant) and
  553.               (PVarData(ParamPtr^)^.VType = varString) then
  554.               VarCast(PVariant(ParamPtr^)^, PVariant(ParamPtr^)^, varOleStr);
  555.             ArgPtr^[0] := ArgType or varByRef;
  556.             ArgPtr^[2] := ParamPtr^;
  557.           end else
  558.           if ArgType = varVariant then
  559.           begin
  560.             if PVarData(ParamPtr^)^.VType = varString then
  561.             begin
  562.               with Strings[StrCount] do
  563.               begin
  564.                 BStr := StringToOleStr(string(PVarData(ParamPtr^)^.VString));
  565.                 PStr := nil;
  566.                 ArgPtr^[0] := varOleStr;
  567.                 ArgPtr^[2] := Integer(BStr);
  568.               end;
  569.               Inc(StrCount);
  570.             end else
  571.             begin
  572.               VarPtr := PVarArg(ParamPtr);
  573.               ArgPtr^[0] := VarPtr^[0];
  574.               ArgPtr^[1] := VarPtr^[1];
  575.               ArgPtr^[2] := VarPtr^[2];
  576.               ArgPtr^[3] := VarPtr^[3];
  577.               Inc(Integer(ParamPtr), 12);
  578.             end;
  579.           end else
  580.           begin
  581.             ArgPtr^[0] := ArgType;
  582.             ArgPtr^[2] := ParamPtr^;
  583.             if (ArgType >= varDouble) and (ArgType <= varDate) then
  584.             begin
  585.               Inc(Integer(ParamPtr), 4);
  586.               ArgPtr^[3] := ParamPtr^;
  587.             end;
  588.           end;
  589.           Inc(Integer(ParamPtr), 4);
  590.         end;
  591.         Inc(I);
  592.       until I = ArgCount;
  593.     end;
  594.     DispParams.rgvarg := @Args;
  595.     DispParams.rgdispidNamedArgs := @DispIDs[1];
  596.     DispParams.cArgs := ArgCount;
  597.     DispParams.cNamedArgs := CallDesc^.NamedArgCount;
  598.     DispID := DispIDs[0];
  599.     InvKind := CallDesc^.CallType;
  600.     if InvKind = DISPATCH_PROPERTYPUT then
  601.     begin
  602.       if Args[0][0] and varTypeMask = varDispatch then
  603.         InvKind := DISPATCH_PROPERTYPUTREF;
  604.       DispIDs[0] := DISPID_PROPERTYPUT;
  605.       Dec(Integer(DispParams.rgdispidNamedArgs), SizeOf(Integer));
  606.       Inc(DispParams.cNamedArgs);
  607.     end else
  608.       if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then
  609.         InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
  610.     Status := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, DispParams,
  611.       Result, @ExcepInfo, nil);
  612.     if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
  613.     J := StrCount;
  614.     while J <> 0 do
  615.     begin
  616.       Dec(J);
  617.       with Strings[J] do
  618.         if PStr <> nil then OleStrToStrVar(BStr, PStr^);
  619.     end;
  620.   finally
  621.     K := StrCount;
  622.     while K <> 0 do
  623.     begin
  624.       Dec(K);
  625.       SysFreeString(Strings[K].BStr);
  626.     end;
  627.   end;
  628. end;
  629.  
  630. { Raise exception given an OLE return code and TExcepInfo structure }
  631.  
  632. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  633. begin
  634.   if Status <> DISP_E_EXCEPTION then OleError(Status);
  635.   with ExcepInfo do
  636.     raise EOleException.Create(bstrDescription, scode, bstrSource,
  637.       bstrHelpFile, dwHelpContext);
  638. end;
  639.  
  640. { Call GetIDsOfNames method on the given IDispatch interface }
  641.  
  642. procedure GetIDsOfNames(Dispatch: IDispatch; Names: PChar;
  643.   NameCount: Integer; DispIDs: PDispIDList);
  644. var
  645.   I, N: Integer;
  646.   Ch: WideChar;
  647.   P: PWideChar;
  648.   NameRefs: array[0..MaxDispArgs - 1] of PWideChar;
  649.   WideNames: array[0..1023] of WideChar;
  650. begin
  651.   I := 0;
  652.   N := 0;
  653.   repeat
  654.     P := @WideNames[I];
  655.     if N = 0 then NameRefs[0] := P else NameRefs[NameCount - N] := P;
  656.     repeat
  657.       Ch := WideChar(Names[I]);
  658.       WideNames[I] := Ch;
  659.       Inc(I);
  660.     until Char(Ch) = #0;
  661.     Inc(N);
  662.   until N = NameCount;
  663.   if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,
  664.     LOCALE_SYSTEM_DEFAULT, DispIDs) <> 0 then
  665.     raise EOleError.CreateFmt(SNoMethod, [Names]);
  666. end;
  667.  
  668. { Central call dispatcher }
  669.  
  670. procedure VarDispInvoke(Result: PVariant; const Instance: Variant;
  671.   CallDesc: PCallDesc; Params: Pointer); cdecl;
  672. var
  673.   Dispatch: Pointer;
  674.   DispIDs: array[0..MaxDispArgs - 1] of Integer;
  675. begin
  676.   if TVarData(Instance).VType = varDispatch then
  677.     Dispatch := TVarData(Instance).VDispatch
  678.   else if TVarData(Instance).VType = (varDispatch or varByRef) then
  679.     Dispatch := Pointer(TVarData(Instance).VPointer^)
  680.   else
  681.     raise EOleError.Create(SVarNotObject);
  682.   GetIDsOfNames(IDispatch(Dispatch), @CallDesc^.ArgTypes[CallDesc^.ArgCount],
  683.     CallDesc^.NamedArgCount + 1, @DispIDs);
  684.   if Result <> nil then VarClear(Result^);
  685.   DispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, @Params, Result);
  686. end;
  687.  
  688. { Raise exception given an OLE return code and TExcepInfo structure }
  689.  
  690. procedure DispCallError(Status: Integer; var ExcepInfo: TExcepInfo;
  691.   ErrorAddr: Pointer);
  692. var
  693.   E: Exception;
  694. begin
  695.   if Status = DISP_E_EXCEPTION then
  696.   begin
  697.     with ExcepInfo do
  698.       E := EOleException.Create(bstrDescription, scode, bstrSource,
  699.         bstrHelpFile, dwHelpContext);
  700.     Finalize(ExcepInfo);
  701.   end else
  702.     E := EOleSysError.Create('', Status, 0);
  703.   raise E at ErrorAddr;
  704. end;
  705.  
  706. procedure DispCall(const Dispatch: IDispatch; CallDesc: PCallDesc;
  707.   DispID: Integer; NamedArgDispIDs, Params, Result: Pointer); stdcall;
  708. type
  709.   TExcepInfoRec = record
  710.     wCode: Word;
  711.     wReserved: Word;
  712.     bstrSource: PWideChar;
  713.     bstrDescription: PWideChar;
  714.     bstrHelpFile: PWideChar;
  715.     dwHelpContext: Longint;
  716.     pvReserved: Pointer;
  717.     pfnDeferredFillIn: Pointer;
  718.     scode: HResult;
  719.   end;
  720. var
  721.   DispParams: TDispParams;
  722.   ExcepInfo: TExcepInfoRec;
  723. asm
  724.         PUSH    EBX
  725.         PUSH    ESI
  726.         PUSH    EDI
  727.         MOV     EBX,CallDesc
  728.         XOR     EDX,EDX
  729.         MOV     EDI,ESP
  730.         MOVZX   ECX,[EBX].TCallDesc.ArgCount
  731.         MOV     DispParams.cArgs,ECX
  732.         TEST    ECX,ECX
  733.         JE      @@10
  734.         ADD     EBX,OFFSET TCallDesc.ArgTypes
  735.         MOV     ESI,Params
  736. @@1:    MOVZX   EAX,[EBX].Byte
  737.         TEST    AL,atByRef
  738.         JNE     @@3
  739.         CMP     AL,varVariant
  740.         JE      @@2
  741.         CMP     AL,varDouble
  742.         JB      @@4
  743.         CMP     AL,varDate
  744.         JA      @@4
  745.         PUSH    [ESI].Integer[4]
  746.         PUSH    [ESI].Integer[0]
  747.         PUSH    EDX
  748.         PUSH    EAX
  749.         ADD     ESI,8
  750.         JMP     @@5
  751. @@2:    PUSH    [ESI].Integer[12]
  752.         PUSH    [ESI].Integer[8]
  753.         PUSH    [ESI].Integer[4]
  754.         PUSH    [ESI].Integer[0]
  755.         ADD     ESI,16
  756.         JMP     @@5
  757. @@3:    AND     AL,atTypeMask
  758.         OR      EAX,varByRef
  759. @@4:    PUSH    EDX
  760.         PUSH    [ESI].Integer[0]
  761.         PUSH    EDX
  762.         PUSH    EAX
  763.         ADD     ESI,4
  764. @@5:    INC     EBX
  765.         DEC     ECX
  766.         JNE     @@1
  767.         MOV     EBX,CallDesc
  768. @@10:   MOV     DispParams.rgvarg,ESP
  769.         MOVZX   EAX,[EBX].TCallDesc.NamedArgCount
  770.         MOV     DispParams.cNamedArgs,EAX
  771.         TEST    EAX,EAX
  772.         JE      @@12
  773.         MOV     ESI,NamedArgDispIDs
  774. @@11:   PUSH    [ESI].Integer[EAX*4-4]
  775.         DEC     EAX
  776.         JNE     @@11
  777. @@12:   MOVZX   ECX,[EBX].TCallDesc.CallType
  778.         CMP     ECX,DISPATCH_PROPERTYPUT
  779.         JNE     @@20
  780.         PUSH    DISPID_PROPERTYPUT
  781.         INC     DispParams.cNamedArgs
  782.         CMP     [EBX].TCallDesc.ArgTypes.Byte[0],varDispatch
  783.         JE      @@13
  784.         CMP     [EBX].TCallDesc.ArgTypes.Byte[0],varUnknown
  785.         JNE     @@20
  786. @@13:   MOV     ECX,DISPATCH_PROPERTYPUTREF
  787. @@20:   MOV     DispParams.rgdispidNamedArgs,ESP
  788.         PUSH    EDX                     { ArgErr }
  789.         LEA     EAX,ExcepInfo
  790.         PUSH    EAX                     { ExcepInfo }
  791.         PUSH    Result                  { VarResult }
  792.         LEA     EAX,DispParams
  793.         PUSH    EAX                     { Params }
  794.         PUSH    ECX                     { Flags }
  795.         PUSH    EDX                     { LocaleID }
  796.         PUSH    OFFSET GUID_NULL        { IID }
  797.         PUSH    DispID                  { DispID }
  798.         MOV     EAX,Dispatch
  799.         PUSH    EAX
  800.         MOV     EAX,[EAX]
  801.         CALL    [EAX].Pointer[24]
  802.         TEST    EAX,EAX
  803.         JE      @@30
  804.         LEA     EDX,ExcepInfo
  805.         MOV     ECX,[EBP+4]
  806.         JMP     DispCallError
  807. @@30:   MOV     ESP,EDI
  808.         POP     EDI
  809.         POP     ESI
  810.         POP     EBX
  811. end;
  812.  
  813. procedure DispCallByID(Result: Pointer; const Dispatch: IDispatch;
  814.   DispDesc: PDispDesc; Params: Pointer); cdecl;
  815. asm
  816.         PUSH    EBX
  817.         MOV     EBX,DispDesc
  818.         XOR     EAX,EAX
  819.         PUSH    EAX
  820.         PUSH    EAX
  821.         PUSH    EAX
  822.         PUSH    EAX
  823.         MOV     EAX,ESP
  824.         PUSH    EAX
  825.         LEA     EAX,Params
  826.         PUSH    EAX
  827.         PUSH    EAX
  828.         PUSH    [EBX].TDispDesc.DispID
  829.         LEA     EAX,[EBX].TDispDesc.CallDesc
  830.         PUSH    EAX
  831.         PUSH    Dispatch
  832.         CALL    DispCall
  833.         MOVZX   EAX,[EBX].TDispDesc.ResType
  834.         MOV     EBX,Result
  835.         JMP     @ResultTable.Pointer[EAX*4]
  836.  
  837. @ResultTable:
  838.         DD      @ResEmpty
  839.         DD      @ResNull
  840.         DD      @ResSmallint
  841.         DD      @ResInteger
  842.         DD      @ResSingle
  843.         DD      @ResDouble
  844.         DD      @ResCurrency
  845.         DD      @ResDate
  846.         DD      @ResString
  847.         DD      @ResDispatch
  848.         DD      @ResError
  849.         DD      @ResBoolean
  850.         DD      @ResVariant
  851.         DD      @ResUnknown
  852.         DD      @ResDecimal
  853.         DD      @ResError
  854.         DD      @ResByte
  855.  
  856. @ResSingle:
  857.         FLD     [ESP+8].Single
  858.         JMP     @ResDone
  859.  
  860. @ResDouble:
  861. @ResDate:
  862.         FLD     [ESP+8].Double
  863.         JMP     @ResDone
  864.  
  865. @ResCurrency:
  866.         FILD    [ESP+8].Currency
  867.         JMP     @ResDone
  868.  
  869. @ResString:
  870.         MOV     EAX,[EBX]
  871.         TEST    EAX,EAX
  872.         JE      @@1
  873.         PUSH    EAX
  874.         CALL    SysFreeString
  875. @@1:    MOV     EAX,[ESP+8]
  876.         MOV     [EBX],EAX
  877.         JMP     @ResDone
  878.  
  879. @ResDispatch:
  880. @ResUnknown:
  881.         MOV     EAX,[EBX]
  882.         TEST    EAX,EAX
  883.         JE      @@2
  884.         PUSH    EAX
  885.         MOV     EAX,[EAX]
  886.         CALL    [EAX].Pointer[8]
  887. @@2:    MOV     EAX,[ESP+8]
  888.         MOV     [EBX],EAX
  889.         JMP     @ResDone
  890.  
  891. @ResVariant:
  892.         MOV     EAX,EBX
  893.         CALL    VarClear
  894.         MOV     EAX,[ESP]
  895.         MOV     [EBX],EAX
  896.         MOV     EAX,[ESP+4]
  897.         MOV     [EBX+4],EAX
  898.         MOV     EAX,[ESP+8]
  899.         MOV     [EBX+8],EAX
  900.         MOV     EAX,[ESP+12]
  901.         MOV     [EBX+12],EAX
  902.         JMP     @ResDone
  903.  
  904. @ResSmallint:
  905. @ResInteger:
  906. @ResBoolean:
  907. @ResByte:
  908.         MOV     EAX,[ESP+8]
  909.  
  910. @ResDecimal:
  911. @ResEmpty:
  912. @ResNull:
  913. @ResError:
  914. @ResDone:
  915.         ADD     ESP,16
  916.         POP     EBX
  917. end;
  918.  
  919. { Handle a safe call exception }
  920.  
  921. function HandleSafeCallException(ExceptObject: TObject;
  922.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  923.   HelpFileName: WideString): HResult;
  924. var
  925.   E: TObject;
  926.   CreateError: ICreateErrorInfo;
  927.   ErrorInfo: IErrorInfo;
  928. begin
  929.   Result := E_UNEXPECTED;
  930.   E := ExceptObject;
  931.   if CreateErrorInfo(CreateError) = S_OK then
  932.   begin
  933.     CreateError.SetGUID(ErrorIID);
  934.     if ProgID <> '' then CreateError.SetSource(PWideChar(ProgID));
  935.     if HelpFileName <> '' then CreateError.SetHelpFile(PWideChar(HelpFileName));
  936.     if E is Exception then
  937.     begin
  938.       CreateError.SetDescription(PWideChar(WideString(Exception(E).Message)));
  939.       CreateError.SetHelpContext(Exception(E).HelpContext);
  940.       if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
  941.         Result := EOleSysError(E).ErrorCode;
  942.     end;
  943.     if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then
  944.       SetErrorInfo(0, ErrorInfo);
  945.   end;
  946. end;
  947.  
  948. { EOleSysError }
  949.  
  950. constructor EOleSysError.Create(const Message: string;
  951.   ErrorCode, HelpContext: Integer);
  952. var
  953.   S: string;
  954. begin
  955.   S := Message;
  956.   if S = '' then
  957.   begin
  958.     S := SysErrorMessage(ErrorCode);
  959.     if S = '' then FmtStr(S, SOleError, [ErrorCode]);
  960.   end;
  961.   inherited CreateHelp(S, HelpContext);
  962.   FErrorCode := ErrorCode;
  963. end;
  964.  
  965. { EOleException }
  966.  
  967. constructor EOleException.Create(const Message: string; ErrorCode: Integer;
  968.   const Source, HelpFile: string; HelpContext: Integer);
  969. begin
  970.   inherited Create(TrimPunctuation(Message), ErrorCode, HelpContext);
  971.   FSource := Source;
  972.   FHelpFile := HelpFile;
  973. end;
  974.  
  975. { TComClassManager }
  976.  
  977. procedure TComClassManager.AddObjectFactory(Factory: TComObjectFactory);
  978. begin
  979.   Factory.FNext := FFactoryList;
  980.   FFactoryList := Factory;
  981. end;
  982.  
  983. procedure TComClassManager.ForEachFactory(ComServer: TComServerObject;
  984.   FactoryProc: TFactoryProc);
  985. var
  986.   Factory, Next: TComObjectFactory;
  987. begin
  988.   Factory := FFactoryList;
  989.   while Factory <> nil do
  990.   begin
  991.     Next := Factory.FNext;
  992.     if Factory.ComServer = ComServer then FactoryProc(Factory);
  993.     Factory := Next;
  994.   end;
  995. end;
  996.  
  997. function TComClassManager.GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  998. begin
  999.   Result := FFactoryList;
  1000.   while Result <> nil do
  1001.   begin
  1002.     if Result.ComClass = ComClass then Exit;
  1003.     Result := Result.FNext;
  1004.   end;
  1005.   raise EOleError.CreateFmt(SObjectFactoryMissing, [ComClass.ClassName]);
  1006. end;
  1007.  
  1008. function TComClassManager.GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  1009. begin
  1010.   Result := FFactoryList;
  1011.   while Result <> nil do
  1012.   begin
  1013.     if IsEqualGUID(Result.ClassID, ClassID) then Exit;
  1014.     Result := Result.FNext;
  1015.   end;
  1016. end;
  1017.  
  1018. procedure TComClassManager.RemoveObjectFactory(Factory: TComObjectFactory);
  1019. var
  1020.   F, P: TComObjectFactory;
  1021. begin
  1022.   P := nil;
  1023.   F := FFactoryList;
  1024.   while F <> nil do
  1025.   begin
  1026.     if F = Factory then
  1027.     begin
  1028.       if P <> nil then P.FNext := F.FNext else FFactoryList := F.FNext;
  1029.       Exit;
  1030.     end;
  1031.     P := F;
  1032.     F := F.FNext;
  1033.   end;
  1034. end;
  1035.  
  1036. { TComObject }
  1037.  
  1038. constructor TComObject.Create;
  1039. begin
  1040.   CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), nil);
  1041. end;
  1042.  
  1043. constructor TComObject.CreateAggregated(const Controller: IUnknown);
  1044. begin
  1045.   CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), Controller);
  1046. end;
  1047.  
  1048. constructor TComObject.CreateFromFactory(Factory: TComObjectFactory;
  1049.   const Controller: IUnknown);
  1050. begin
  1051.   FRefCount := 1;
  1052.   FFactory := Factory;
  1053.   FController := Pointer(Controller);
  1054.   FFactory.ComServer.CountObject(True);
  1055.   Initialize;
  1056.   Dec(FRefCount);
  1057. end;
  1058.  
  1059. destructor TComObject.Destroy;
  1060. begin
  1061.   if not OleUninitializing and (FFactory <> nil) then
  1062.     FFactory.ComServer.CountObject(False);
  1063. end;
  1064.  
  1065. function TComObject.GetController: IUnknown;
  1066. begin
  1067.   Result := IUnknown(FController);
  1068. end;
  1069.  
  1070. procedure TComObject.Initialize;
  1071. begin
  1072. end;
  1073.  
  1074. function TComObject.SafeCallException(ExceptObject: TObject;
  1075.   ExceptAddr: Pointer): HResult;
  1076. begin
  1077.   Result := HandleSafeCallException(ExceptObject, ExceptAddr,
  1078.     FFactory.ErrorIID, FFactory.ProgID, FFactory.ComServer.HelpFileName);
  1079. end;
  1080.  
  1081. { TComObject.IUnknown }
  1082.  
  1083. function TComObject.ObjQueryInterface(const IID: TGUID; out Obj): Integer;
  1084. begin
  1085.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  1086. end;
  1087.  
  1088. function TComObject.ObjAddRef: Integer;
  1089. begin
  1090.   Inc(FRefCount);
  1091.   Result := FRefCount;
  1092. end;
  1093.  
  1094. function TComObject.ObjRelease: Integer;
  1095. begin
  1096.   Dec(FRefCount);
  1097.   if FRefCount = 0 then
  1098.   begin
  1099.     Destroy;
  1100.     Result := 0;
  1101.     Exit;
  1102.   end;
  1103.   Result := FRefCount;
  1104. end;
  1105.  
  1106. { TComObject.IUnknown for other interfaces }
  1107.  
  1108. function TComObject.QueryInterface(const IID: TGUID; out Obj): Integer;
  1109. begin
  1110.   if FController <> nil then
  1111.     Result := IUnknown(FController).QueryInterface(IID, Obj) else
  1112.     Result := ObjQueryInterface(IID, Obj);
  1113. end;
  1114.  
  1115. function TComObject._AddRef: Integer;
  1116. begin
  1117.   if FController <> nil then
  1118.     Result := IUnknown(FController)._AddRef else
  1119.     Result := ObjAddRef;
  1120. end;
  1121.  
  1122. function TComObject._Release: Integer;
  1123. begin
  1124.   if FController <> nil then
  1125.     Result := IUnknown(FController)._Release else
  1126.     Result := ObjRelease;
  1127. end;
  1128.  
  1129. { TComObject.ISupportErrorInfo }
  1130.  
  1131. function TComObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
  1132. begin
  1133.   if GetInterfaceEntry(iid) <> nil then
  1134.     Result := S_OK else
  1135.     Result := S_FALSE;
  1136. end;
  1137.  
  1138. { TComObjectFactory }
  1139.  
  1140. constructor TComObjectFactory.Create(ComServer: TComServerObject;
  1141.   ComClass: TComClass; const ClassID: TGUID; const ClassName,
  1142.   Description: string; Instancing: TClassInstancing);
  1143. begin
  1144.   ComClassManager.AddObjectFactory(Self);
  1145.   FComServer := ComServer;
  1146.   FComClass := ComClass;
  1147.   FClassID := ClassID;
  1148.   FClassName := ClassName;
  1149.   FDescription := Description;
  1150.   FInstancing := Instancing;
  1151.   FErrorIID := IUnknown;
  1152. end;
  1153.  
  1154. destructor TComObjectFactory.Destroy;
  1155. begin
  1156.   if FRegister <> 0 then CoRevokeClassObject(FRegister);
  1157.   ComClassManager.RemoveObjectFactory(Self);
  1158. end;
  1159.  
  1160. function TComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject;
  1161. begin
  1162.   Result := TComClass(FComClass).CreateFromFactory(Self, Controller);
  1163. end;
  1164.  
  1165. function TComObjectFactory.GetProgID: string;
  1166. begin
  1167.   if FClassName <> '' then
  1168.     Result := FComServer.ServerName + '.' + FClassName else
  1169.     Result := '';
  1170. end;
  1171.  
  1172. procedure TComObjectFactory.RegisterClassObject;
  1173. const
  1174.   RegFlags: array[ciSingleInstance..ciMultiInstance] of Integer = (
  1175.     REGCLS_SINGLEUSE, REGCLS_MULTIPLEUSE);
  1176. begin
  1177.   OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
  1178.     RegFlags[FInstancing], FRegister));
  1179. end;
  1180.  
  1181. procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
  1182. var
  1183.   ClassID, ProgID: string;
  1184. begin
  1185.   ClassID := GUIDToString(FClassID);
  1186.   ProgID := GetProgID;
  1187.   if Register then
  1188.   begin
  1189.     CreateRegKey('CLSID\' + ClassID, '', Description);
  1190.     CreateRegKey('CLSID\' + ClassID + '\' + FComServer.ServerKey,
  1191.       '', FComServer.ServerFileName);
  1192.     CreateRegKey('CLSID\' + ClassID + '\' + FComServer.ServerKey,
  1193.       'ThreadingModel', 'Apartment');
  1194.     if ProgID <> '' then
  1195.     begin
  1196.       CreateRegKey(ProgID, '', Description);
  1197.       CreateRegKey(ProgID + '\Clsid', '', ClassID);
  1198.       CreateRegKey('CLSID\' + ClassID + '\ProgID', '', ProgID);
  1199.     end;
  1200.   end else
  1201.   begin
  1202.     if ProgID <> '' then
  1203.     begin
  1204.       DeleteRegKey('CLSID\' + ClassID + '\ProgID');
  1205.       DeleteRegKey(ProgID + '\Clsid');
  1206.       DeleteRegKey(ProgID);
  1207.     end;
  1208.     DeleteRegKey('CLSID\' + ClassID + '\' + FComServer.ServerKey);
  1209.     DeleteRegKey('CLSID\' + ClassID);
  1210.   end;
  1211. end;
  1212.  
  1213. function TComObjectFactory.GetLicenseString: WideString;
  1214. begin
  1215.   if FSupportsLicensing then Result := FLicString
  1216.   else Result := '';
  1217. end;
  1218.  
  1219. function TComObjectFactory.HasMachineLicense: Boolean;
  1220. begin
  1221.   Result := True;
  1222. end;
  1223.  
  1224. function TComObjectFactory.ValidateUserLicense(const LicStr: WideString): Boolean;
  1225. begin
  1226.   Result := AnsiCompareText(LicStr, FLicString) = 0;
  1227. end;
  1228.  
  1229. { TComObjectFactory.IUnknown }
  1230.  
  1231. function TComObjectFactory.QueryInterface(const IID: TGUID; out Obj): Integer;
  1232. begin
  1233.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  1234. end;
  1235.  
  1236. function TComObjectFactory._AddRef: Integer;
  1237. begin
  1238.   Result := ComServer.CountFactory(True);
  1239. end;
  1240.  
  1241. function TComObjectFactory._Release: Integer;
  1242. begin
  1243.   Result := ComServer.CountFactory(False);
  1244. end;
  1245.  
  1246. { TComObjectFactory.IClassFactory }
  1247.  
  1248. function TComObjectFactory.CreateInstance(const UnkOuter: IUnknown;
  1249.   const IID: TGUID; out Obj): HResult;
  1250. begin
  1251.   Result := CreateInstanceLic(UnkOuter, nil, IID, '', Obj);
  1252. end;
  1253.  
  1254. function TComObjectFactory.LockServer(fLock: BOOL): HResult;
  1255. begin
  1256.   Result := CoLockObjectExternal(Self, fLock, True);
  1257. end;
  1258.  
  1259. { TComObjectFactory.IClassFactory2 }
  1260.  
  1261. function TComObjectFactory.GetLicInfo(var licInfo: TLicInfo): HResult;
  1262. begin
  1263.   Result := S_OK;
  1264.   try
  1265.     with licInfo do
  1266.     begin
  1267.       cbLicInfo := SizeOf(licInfo);
  1268.       fRuntimeKeyAvail := (not FSupportsLicensing) or (GetLicenseString <> '');
  1269.       fLicVerified := (not FSupportsLicensing) or HasMachineLicense;
  1270.     end;
  1271.   except
  1272.     Result := E_UNEXPECTED;
  1273.   end;
  1274. end;
  1275.  
  1276. function TComObjectFactory.RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult;
  1277. begin
  1278.   // Can't give away a license key on an unlicensed machine
  1279.   if not HasMachineLicense then
  1280.   begin
  1281.     Result := CLASS_E_NOTLICENSED;
  1282.     Exit;
  1283.   end;
  1284.   bstrKey := FLicString;
  1285.   Result := NOERROR;
  1286. end;
  1287.  
  1288. function TComObjectFactory.CreateInstanceLic(const unkOuter: IUnknown;
  1289.   const unkReserved: IUnknown; const iid: TIID; const bstrKey: WideString;
  1290.   out vObject): HResult; stdcall;
  1291. var
  1292.   ComObject: TComObject;
  1293. begin
  1294.   if FSupportsLicensing and
  1295.     ((bstrKey <> '') and (not ValidateUserLicense(bstrKey))) or
  1296.     ((bstrKey = '') and (not HasMachineLicense)) then
  1297.   begin
  1298.     Result := CLASS_E_NOTLICENSED;
  1299.     Exit;
  1300.   end;
  1301.   Pointer(vObject) := nil;
  1302.   try
  1303.     ComObject := CreateComObject(UnkOuter);
  1304.   except
  1305.     Result := E_UNEXPECTED;
  1306.     Exit;
  1307.   end;
  1308.   Result := ComObject.ObjQueryInterface(IID, vObject);
  1309.   if ComObject.RefCount = 0 then ComObject.Free;
  1310. end;
  1311.  
  1312. { TTypedComObject.IProvideClassInfo }
  1313.  
  1314. function TTypedComObject.GetClassInfo(out TypeInfo: ITypeInfo): HResult;
  1315. begin
  1316.   TypeInfo := TTypedComObjectFactory(FFactory).FClassInfo;
  1317.   Result := S_OK;
  1318. end;
  1319.  
  1320. { TTypedComObjectFactory }
  1321.  
  1322. constructor TTypedComObjectFactory.Create(ComServer: TComServerObject;
  1323.   TypedComClass: TTypedComClass; const ClassID: TGUID;
  1324.   Instancing: TClassInstancing);
  1325. var
  1326.   ClassName, Description: WideString;
  1327. begin
  1328.   if ComServer.TypeLib.GetTypeInfoOfGUID(ClassID, FClassInfo) <> S_OK then
  1329.     raise EOleError.CreateFmt(STypeInfoMissing, [TypedComClass.ClassName]);
  1330.   OleCheck(FClassInfo.GetDocumentation(MEMBERID_NIL, @ClassName,
  1331.     @Description, nil, nil));
  1332.   inherited Create(ComServer, TypedComClass, ClassID,
  1333.     ClassName, Description, Instancing);
  1334. end;
  1335.  
  1336. function TTypedComObjectFactory.GetInterfaceTypeInfo(
  1337.   TypeFlags: Integer): ITypeInfo;
  1338. const
  1339.   FlagsMask = IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE;
  1340. var
  1341.   ClassAttr: PTypeAttr;
  1342.   I, TypeInfoCount, Flags: Integer;
  1343.   RefType: HRefType;
  1344. begin
  1345.   OleCheck(FClassInfo.GetTypeAttr(ClassAttr));
  1346.   TypeInfoCount := ClassAttr^.cImplTypes;
  1347.   ClassInfo.ReleaseTypeAttr(ClassAttr);
  1348.   for I := 0 to TypeInfoCount - 1 do
  1349.   begin
  1350.     OleCheck(ClassInfo.GetImplTypeFlags(I, Flags));
  1351.     if Flags and FlagsMask = TypeFlags then
  1352.     begin
  1353.       OleCheck(ClassInfo.GetRefTypeOfImplType(I, RefType));
  1354.       OleCheck(ClassInfo.GetRefTypeInfo(RefType, Result));
  1355.       Exit;
  1356.     end;
  1357.   end;
  1358.   Result := nil;
  1359. end;
  1360.  
  1361. procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
  1362. var
  1363.   ClassKey: string;
  1364.   TypeLib: ITypeLib;
  1365.   TLibAttr: PTLibAttr;
  1366. begin
  1367.   ClassKey := 'CLSID\' + GUIDToString(FClassID);
  1368.   if Register then
  1369.   begin
  1370.     inherited UpdateRegistry(Register);
  1371.     TypeLib := FComServer.TypeLib;
  1372.     OleCheck(TypeLib.GetLibAttr(TLibAttr));
  1373.     try
  1374.       CreateRegKey(ClassKey + '\Version', '', Format('%d.%d',
  1375.         [TLibAttr.wMajorVerNum, TLibAttr.wMinorVerNum]));
  1376.       CreateRegKey(ClassKey + '\TypeLib', '', GUIDToString(TLibAttr.guid));
  1377.     finally
  1378.       TypeLib.ReleaseTLibAttr(TLibAttr);
  1379.     end;
  1380.   end else
  1381.   begin
  1382.     DeleteRegKey(ClassKey + '\TypeLib');
  1383.     DeleteRegKey(ClassKey + '\Version');
  1384.     inherited UpdateRegistry(Register);
  1385.   end;
  1386. end;
  1387.  
  1388. { TAutoObject.IDispatch }
  1389.  
  1390. function TAutoObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1391.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  1392. begin
  1393.   Result := DispGetIDsOfNames(TAutoObjectFactory(Factory).DispTypeInfo,
  1394.     Names, NameCount, DispIDs);
  1395. end;
  1396.  
  1397. function TAutoObject.GetTypeInfo(Index, LocaleID: Integer;
  1398.   out TypeInfo): HResult;
  1399. begin
  1400.   Pointer(TypeInfo) := nil;
  1401.   if Index <> 0 then
  1402.   begin
  1403.     Result := DISP_E_BADINDEX;
  1404.     Exit;
  1405.   end;
  1406.   ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).DispTypeInfo;
  1407.   Result := S_OK;
  1408. end;
  1409.  
  1410. function TAutoObject.GetTypeInfoCount(out Count: Integer): HResult;
  1411. begin
  1412.   Count := 1;
  1413.   Result := S_OK;
  1414. end;
  1415.  
  1416. function TAutoObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  1417.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  1418. const
  1419.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  1420. begin
  1421.   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
  1422.   Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
  1423.     Integer(Self) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset),
  1424.     DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
  1425. end;
  1426.  
  1427. { TAutoObjectFactory }
  1428.  
  1429. constructor TAutoObjectFactory.Create(ComServer: TComServerObject;
  1430.   AutoClass: TAutoClass; const ClassID: TGUID;
  1431.   Instancing: TClassInstancing);
  1432. var
  1433.   TypeAttr: PTypeAttr;
  1434. begin
  1435.   inherited Create(ComServer, AutoClass, ClassID, Instancing);
  1436.   FDispTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT);
  1437.   if FDispTypeInfo = nil then
  1438.     raise EOleError.CreateFmt(SBadTypeInfo, [AutoClass.ClassName]);
  1439.   OleCheck(FDispTypeInfo.GetTypeAttr(TypeAttr));
  1440. //  FDispIntfEntry := AutoClass.GetInterfaceEntry(TypeAttr^.guid);
  1441.   FDispIntfEntry := GetIntfEntry(TypeAttr^.guid);
  1442.   FDispTypeInfo.ReleaseTypeAttr(TypeAttr);
  1443.   if FDispIntfEntry = nil then
  1444.     raise EOleError.CreateFmt(SDispIntfMissing, [AutoClass.ClassName]);
  1445.   FErrorIID := FDispIntfEntry^.IID;
  1446. end;
  1447.  
  1448. function TAutoObjectFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
  1449. begin
  1450.   Result := FComClass.GetInterfaceEntry(Guid);
  1451. end;
  1452.  
  1453. { TAutoIntfObject }
  1454.  
  1455. constructor TAutoIntfObject.Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  1456. begin
  1457.   OleCheck(TypeLib.GetTypeInfoOfGuid(DispIntf, FDispTypeInfo));
  1458.   FDispIntfEntry := GetInterfaceEntry(DispIntf);
  1459. end;
  1460.  
  1461. { TAutoIntfObject.IDispatch }
  1462.  
  1463. function TAutoIntfObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1464.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  1465. begin
  1466.   Result := DispGetIDsOfNames(FDispTypeInfo, Names, NameCount, DispIDs);
  1467. end;
  1468.  
  1469. function TAutoIntfObject.GetTypeInfo(Index, LocaleID: Integer;
  1470.   out TypeInfo): HResult;
  1471. begin
  1472.   Pointer(TypeInfo) := nil;
  1473.   if Index <> 0 then
  1474.   begin
  1475.     Result := DISP_E_BADINDEX;
  1476.     Exit;
  1477.   end;
  1478.   ITypeInfo(TypeInfo) := FDispTypeInfo;
  1479.   Result := S_OK;
  1480. end;
  1481.  
  1482. function TAutoIntfObject.GetTypeInfoCount(out Count: Integer): HResult;
  1483. begin
  1484.   Count := 1;
  1485.   Result := S_OK;
  1486. end;
  1487.  
  1488. function TAutoIntfObject.Invoke(DispID: Integer; const IID: TGUID;
  1489.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  1490.   ArgErr: Pointer): HResult;
  1491. const
  1492.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  1493. begin
  1494.   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
  1495.   Result := FDispTypeInfo.Invoke(Pointer(Integer(Self) +
  1496.     FDispIntfEntry.IOffset), DispID, Flags, TDispParams(Params), VarResult,
  1497.     ExcepInfo, ArgErr);
  1498. end;
  1499.  
  1500. function TAutoIntfObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
  1501. begin
  1502.   if IsEqualGUID(DispIID, iid) then
  1503.     Result := S_OK else
  1504.     Result := S_FALSE;
  1505. end;
  1506.  
  1507. function TAutoIntfObject.SafeCallException(ExceptObject: TObject;
  1508.   ExceptAddr: Pointer): HResult;
  1509. begin
  1510.   Result := HandleSafeCallException(ExceptObject, ExceptAddr, DispIID, '', '');
  1511. end;
  1512.  
  1513. function StringToLPOLESTR(const Source: string): POleStr;
  1514. var
  1515.   SourceLen: Integer;
  1516.   Buffer: PWideChar;
  1517. begin
  1518.   SourceLen := Length(Source);
  1519.   Buffer  := CoTaskMemAlloc((SourceLen+1) * sizeof(WideChar));
  1520.   StringToWideChar( Source, Buffer, SourceLen+1 );
  1521.   Result := POleStr( Buffer );
  1522. end;
  1523.  
  1524. // ----------------------------------------------------------------------
  1525. // Property helpers
  1526. // TODO: these should probably end up as "TPropBag..."
  1527. // ----------------------------------------------------------------------
  1528. procedure ReadPropFromBag( PropBag: IPropertyBag; ErrorLog: IErrorLog; const Name: string; var Value: Variant);
  1529. var
  1530.   ws: PWideChar;
  1531.   hRes: HResult;
  1532. begin
  1533.   ws := StringToOleStr( Name );   //!! Use WideString type?
  1534.   hRes := PropBag.Read( ws, Value, ErrorLog );
  1535.   SysFreeString(ws);
  1536.   // on error: if the requested property is not found, clear the result, else throw exception
  1537.   if FAILED(hRes) then
  1538.     if hRes = E_INVALIDARG then
  1539.       VarClear( Value )
  1540.     else
  1541.       OleCheck( hRes );
  1542. end;
  1543.  
  1544. procedure PutPropInBag( PropBag: IPropertyBag; const Name: String; const Value: Variant);
  1545. var
  1546.   ws: PWideChar;
  1547. begin
  1548.   ws := StringToOleStr( Name );  //!! Use WideString type?
  1549.   OleCheck(PropBag.Write( ws, Value ));
  1550.   SysFreeString(ws);
  1551. end;
  1552.  
  1553. procedure RegisterComServer(const DLLName: string);
  1554. type
  1555.   TRegProc = function: HResult; stdcall;
  1556. const
  1557.   RegProcName = 'DllRegisterServer'; { Do not localize }
  1558. var
  1559.   Handle: THandle;
  1560.   RegProc: TRegProc;
  1561. begin
  1562.   Handle := LoadLibrary(PChar(DLLName));
  1563.   if Handle <= HINSTANCE_ERROR then
  1564.     raise Exception.CreateFmt('%s: %s', [SysErrorMessage(GetLastError), DLLName]);
  1565.   try
  1566.     RegProc := GetProcAddress(Handle, RegProcName);
  1567.     if Assigned(RegProc) then OleCheck(RegProc) else RaiseLastWin32Error;
  1568.   finally
  1569.     FreeLibrary(Handle);
  1570.   end;
  1571. end;
  1572.  
  1573. initialization
  1574. begin
  1575.   CoInitialize(nil);
  1576.   ComClassManager := TComClassManager.Create;
  1577.   SafeCallErrorProc := @SafeCallError;
  1578.   VarDispProc := @VarDispInvoke;
  1579.   DispCallByIDProc := @DispCallByID;
  1580. end;
  1581.  
  1582. finalization
  1583. begin
  1584.   OleUninitializing := True;
  1585.   if OleLib <> 0 then FreeLibrary(OleLib);
  1586.   DispCallByIDProc := nil;
  1587.   VarDispProc := nil;
  1588.   SafeCallErrorProc := nil;
  1589.   ComClassManager.Free;
  1590.   CoUninitialize;
  1591. end;
  1592.  
  1593. end.
  1594.